Aminet 1

home *** CD-ROM | disk | FTP | other *** search

/ Aminet 1 / Aminet - June 1993 [Walnut Creek].iso / usenet / sources / volume90 / aplictns / dtc / part03 < prev next >

Wrap

Internet Message Format | 1990-03-14 | 40.3 KB

Path: xanth!cs.odu.edu!Amiga-Request From: Amiga-Request@cs.odu.edu (Amiga Sources/Binaries Moderator) Newsgroups: comp.sources.amiga Subject: v90i109: DTC - desktop calendar, Part03/06 Message-ID: <11788@xanth.cs.odu.edu> Date: 14 Mar 90 01:32:03 GMT Sender: tadguy@cs.odu.edu Reply-To: "Glenn Everhart: 215 354 7610 (8*747 7610)" <EVERHART@ARISIA.dnet.ge.com> Lines: 1546 Approved: tadguy@cs.odu.edu (Tad Guy) X-Mail-Submissions-To: Amiga@cs.odu.edu X-Post-Discussions-To: comp.sys.amiga Submitted-by: "Glenn Everhart: 215 354 7610 (8*747 7610)" <EVERHART@ARISIA.dnet.ge.com> Posting-number: Volume 90, Issue 109 Archive-name: applications/dtc/part03 #!/bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh <file", e.g.. If this archive is complete, you # will see the following message at the end: # "End of archive 3 (of 6)." # Contents: Dtc2.For.ab # Wrapped by tadguy@xanth on Tue Mar 13 20:29:24 1990 PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f 'Dtc2.For.ab' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'Dtc2.For.ab'\" else echo shar: Extracting \"'Dtc2.For.ab'\" $37658 characters$ sed "s/^X//" >'Dtc2.For.ab' <<'END_OF_FILE' X im=idmo X id=iddy X iye=ibigyr X call dtcalcdow (isx, imx, im, iye) XC Get day-of-week for B/O/M X X idx = mod (id + isx - 2, 7) + 1 XC Calc current d/o/w X X call dtcidate(imr, idr, iyr) XC Get today's date X XC if current = today, XC flag current time X if ((im .eq. imr) .and. X 1 (id .eq. idr) .and. X 2 (iye .eq. iyr)) then XC Displaying current day X Call time(iscnds) X scnds=iscnds X scnds = amax1(scnds, 28801.) XC Get current time (>8 AM) X ihalf = mod(ifix(scnds/1800.), 48) XC current half-hour (orig 0) X ihour = ihalf/2 XC Current hour X ihalf = ihalf - (ihour*2) XC 0 or 1 for half-hour X X else X ihour = 0 XC Set non-match value X endif X Xc ************************** Move the cursor to top of screen and clear it, Xc ************************** set up appointments display: X write(*,4) esc,homescrn, esc,clrscrn X 4 format($, 4a, $) X X write(*,5,err=598) X 1 daylist(idx), mthlist(im), id, ibigyr X 5 format(1x,'Schedule - ', a6,'day, ', a9, i3, ',', i5) Xc write(*,5) ' ', esc,dhdw2, Xc 1 daylist(idx), mthlist(im), id, ibigyr X598 continue X X Do (i=8,16) X If ( i .gt. 12 ) then X j = i - 12 X Else X j = i X End If X X if (i .ne. ihour) then XC Check for highlighting X write(*,6) j X write(*,7) j X else XC must be current hour X if (ihalf .eq. 0) then XC Check which half X write(*,96) esc,revattr, j, esc,resetvattr X write(*,7) j X else X write(*,6) j X write(*,97) esc,revattr, j, esc,resetvattr X endif X X endif X end do X X 6 format(1x,i2,':00 -') X 7 format(1x,i2,':30 -') X 96 format (2x, 2a, i2,':00', 2a, ' -') X 97 format (2x, 2a, i2,':30', 2a, ' -') X X if (ihour .ge. 17) then XC Highlight 'Evening' line X write(*,98) esc, esc X else XC Includes display other than today X write(*,9) X end if X X 9 format(1x, 'Evening -', /, x, 75('=')) X 98 format(1x, a, '[7m Evening', a, '[0m-', /, x, 75('=')) X Xc ******************* Screen has now been displayed, Xc ******************* now check rest of line for time and appointment X X if (ln1 .ne. 0) then XC More characters available? X X iht = 80 XC Default is 8:00 X ihmx = iht XC (only 1 entry) X call dtctimcvt(iht, ihmx) XC Decode time value if present X X ihh1 = (iht+2)/5 XC Adds 1 if trailing 3 X ihh2 = (ihmx+2)/5 XC Result is 16 to 35 X idmx = min0(max0(ihh2-ihh1, 1), 20) XC 8:00>6:00 X iht = min0(iht,173) XC Limit entry time (DTCTIMCVT lim is 180) X Xc Note: range of h1:00>h1:30 is considered only one scheduling interval, Xc similarly h(1)>h(2) is an even number, ending just before h(2), Xc computation forces at least one for interval h1:00>h1:00 X X ifnb = 0 X lnb = 0 X ivx = 0 X ap1 = 0 XC Clear appointment string X X do (i = 1, icmln) X X ll = line(i) X appnt(i) = ll X X if (ll .eq. 0) go to 6789 XC done X X ivx = i XC Save current length X X end do X Xc Was there an appointment string input? Xc If so, put it in file, and display it on screen. Xc If not, move cursor to correct time on screen, Xc then input the appointment, put in file and re-display it. X X 6789 If (ap1 .eq. 0) then XC Empty appointment string X X iy = ihh1 - 13 XC Vertical position for half hour Xc amiga fixup ... iy is 1 less X iy = iy-1 Xc end amiga fixup... X ix = 11 X call dtcat(ix,iy) X ibsp=8 X write(*, 987) blot,ibsp XC write blot, backspace X 987 format ($, 2a1, $) X read(*,13,END=914,err=914) workstr X 13 format(a) X do 305 nnn=1,80 X lapp=81-nnn X if(workstr(lapp:lapp).gt.char(32))goto 306 X workstr(laPP:LAPP)=char(0) X305 continue X306 continue Xc copy appointment for use later... X X ifnb = 0 X lnb = 0 X ivx = 0 X X Do (i = 1, lapp) X X ll = work(i) XC fetch character X X if (ll .gt. 32) then X if (ifnb .eq. 0) ifnb = i XC Flag first non-blank X lnb = i XC Flag last non-blank X X end if X X if (ifnb .ne. 0) then XC Copy after first n/b X ivx = ivx + 1 X appnt(ivx) = ll X end if X X end do X X if (ifnb .eq. 0) go to 914 XC Nothing on read either X X End If X X ivx = min0(ivx, iaptlim) XC ivx = length of string X XC If we are using the 'S' command, add meetings to the indirected files ONLY, XC not to the current (control) file. X X if (ctlfg .ne. 1) then XC Add appointment if D or G X X close (1) XC Insurance X Open ( unit=1,file=FNc(1:fnsz) X 1 ,status='UNKNOWN',form='FORMATTED', X 1 position='append',err=9876) X X ihtxx=iht X do (ixx = 1, idmx) X X write(1,14,err=597) iye,im,id,ihtxx,apstr(1:ivx) X597 Continue X if ((ihtxx/10)*10 .eq. ihtxx) X 1 then X X ihtxx=ihtxx+3 XC IHT is even hour, go to next half hour X X else X X ihtxx=ihtxx+7 XC IHT is a half hour ... make up to next hour X X end if X X end do X X 14 format(i4.4,2i2.2,i3.3,x,a) X X 9876 close(1) X X End If X X else XC Empty line (no appointment to add) X 914 idmx = 0 XC Use as flag for display only X X end if X X eofflg = -1 XC Request OPEN X prveof = 0 XC Set for DO WHILE X X lookind = 0 X if (ctlfg .ne. 0) lookind = 1 XC Set for looking at filenames X X irqhash(1) = ihymd(iye, im, id) XC Set match for file scan X irqhash(2) = irqhash(1) XC One day only X IHTsav=IHT Xc Iht clobbered by dtcrdappt X do while (prveof .ge. 0) X X call dtcrdappt(eofflg, lookind) X X if (eofflg .eq. 1) X 1 then XC Returned with filename string X Xc on scheduling multiple dates via S or G functions, use this occasion to Xc add the record to everyone's calendar file. X X close(2) X Do (nnn=1,90) X nnm=101-nnn X If(Workstr(nnm:nnm).ge.char(32))Goto 963 Xc find last nonblank char in string X End Do X963 Continue X Open (unit=2, file=workstr(istart:nnm), status='UNKNOWN', X 1 form='FORMATTED', X 2 position='APPEND', err=1119) X Xc ihtxx=iht X ihtxx=ihtsav X do (ixx = 1, idmx) X write(2,14,err=596)iye,im,id,ihtxx,apstr(1:ivx) X596 Continue X if ((ihtxx/10)*10 .eq. ihtxx) then X ihtxx=ihtxx+3 XC iht is an even hour ... add the half hour X else X ihtxx=ihtxx+7 XC iht is a half hour ... make up to next hour X end if X X end do X X 1119 close(2) X Xc Display appointment if it matches current date X X else If (eofflg .eq. 0) X 1 then X X iy = min0(max0((((iht+2) / 5) - 13), 3), 22) X Xc Amiga fixup -- iy is 1 less X iy=iy-1 Xc end Amiga fixup X XC Compute vertical posn XC Have we been here before X if (dupb(iy) .eq. 32) X 1 then XC No X dupb(iy) = '-' XC Flag it X else XC Duplicate time stamps, find substitute X do (ix = iy-1, 3, -1) XC Search backward first X if (dupb(ix) .eq. 32) X 1 then X iy = ix XC Save replacement X dupb(iy) = 'v' XC Point to where it should go X go to 3141 XC >>> BREAK <<< X end if X end do X do (ix = iy + 1, 22) XC Search forward X if (dupb(ix) .eq. 32) X 1 then X iy = ix XC Save replacement X dupb(iy) = '^' XC Point to where it should go X go to 3141 XC >>> BREAK <<< X end if X end do X dupb(iy) = blot XC Flag it X end if X X 3141 ix = 2 XC first char to print X if (appoin(1) .ne. 32) X 1 then X ix = 1 XC '12:00 - Appointment' X else X if (iaptln .le. 1) X 1 then X appoin(2) = blot XC Display BLOT for empty entry X iaptln = 2 X end if X end if X X kk = min0(iaptln, iaptlim) X X call dtcat(8,iy) XC Set cursor position X XC flag + text X write(*,300) dupb(iy), ' ', apptstr(ix:kk), X 1 esc,'[K' XC Erase EOL X 300 format($, 5a, $) X X End If XC eofflg .ge. 0 X X prveof = eofflg XC Show what happened X X end do XC while (prveof) X write(*,367) X367 format(' ') Xd write(4,4203) Xd4203 format(' Day .. returning') Xd call dely X call dtcat(1,22) X Return X end XC -h- month.for Tue Jul 8 16:05:05 1986 Xc----------------------------------------------------------------------- XC Month-at-a-glance subroutine XC part of Mitch Wyle's DTC program XC Input: Xc line - 72 INTEGER*1 string; Format: M [dd[19[yy]]] XC Output: Xc display screen (see below) XC Line Xc 1 Prevmonth Nextmonth Xc 2 SMTWTFS SMTWTFS XC 3-8 Calendar Calendar Xc 9/10 Y e a r M o n t h Y e a r Xc 11 S M T W T F S Xc 13-23 C a l e n d a r XC Lines 9/10 are double-height/double-width Xc Odd lines 11-23 are double-width Xc Even lines 10-22 are blank XC----------------------------------------------------------------------- XC Modified 850318, several changes- CG Xc Display today's date in current, prev or next month Xc in reverse video Xc Write out >>> only <<< non-blank flags (*'s) Xc Speed-up of month display (actually in dtcdspmth subr) Xc Months mixed-case and centered (GABY) Xc Modified 850809 - display IBIGYR both sides of month, DH/DW X X SUBROUTINE month XC (line) X Xc Declarations: X X include comdtc.INC X include apptdtc.INC X include escdtc.INC X X INTEGER*1 TEMP X Dimension TEMP(4) XC temporary string converting array X CHARACTER*4 TMPP X EQUIVALENCE(TMPP,TEMP(1)) X Integer*4 id XC Julian Day X Integer*4 im XC Julian Month X Integer*4 iy XC Julian Year X X Integer*4 prveof, eofflg X Xc string month name X INTEGER*1 monthn(9), X 1 lmonth(9) Xc Entries true if lenght of name is even X logical*1 lmneven(12) Xc Entries true if length of name is odd X logical*1 lmnodd(12) X X INTEGER*1 out(79) XC The output string and * array X INTEGER*1 rchr XC Flag set (or reset) character X INTEGER*1 ln1 XC Same as line(1) X include stmtfuncsp.for X equivalence (line, ln1) X Character*41 lxfmt X Character*2 lxfixx,lxfixy X Character*1 lxfc(41) X Equivalence(lxfc(1),lxfmt) X Equivalence (lxfixx,lxfc(14)),(lxfixy,lxfc(27)) X include comdtcd.inc X include escdtcd.inc Xc 8 format(3a, 4(a1, x), <ixx>x, 9(x,a1), <ixy>x, 4(x, a1), $) Xc write(*,8) ' ', esc,dhdw2, temp, monthn, temp Xc X data lxfmt/'(7x,4(a1,2x),01x,9(2x,a1),01x,4(2x,a1),$)'/ X data lmneven/ X 1 .false., .true., .false., .false., .false., .true., X 2 .true., .true., .false., .false., .true., .true./ Xc Entries true if length of name is odd X data lmnodd X 1 /.true., .false., .true., .true., .true., .false., X 2 .false., .false., .true., .true., .false., .false./ X X include stmtfunc.for X Xc Trim off the M from command line: X if(ln1.gt.96)ln1=ln1-32 X if ((ln1 ) .eq. Ichar('M')) X 1 call shrink(1, ifnb, lnb) X X call dtcdatcvt(2) XC Decode date string X X im=idmo XC Pick up result from common X id=iddy X iy=ibigyr X X call dtcidate(irm,ird,iry) XC Real month,day,year, for display highlight X Xc Move the cursor to the top part, clear the screen X X write(*,600) esc,homescrn, esc,clrscrn X 600 format ($, 4a, $) X Call Dtcat(1,1) Xc Now start building the output string: (out) X X WRITE(TMPP,20,ERR=11)IY XC encode(4, 20, temp, err=11) iy X 11 continue X 20 format(i4) X Xc Calculate nominal prev, next month numbers X X lm = im - 1 X ly = iy X nm = im + 1 X ny = iy X X If ( im .eq. 1 ) then X X lm = 12 X ly = iy - 1 X X else If ( im .eq. 12 ) then X X nm = 1 X ny = iy + 1 X X End If X XC PRINT PREVIOUS MONTH X call dtcmthnam(lm,lmonth) X XC PRINT NEXT MONTH CALENDAR AT TOP X call dtcmthnam(nm,monthn) X XC WRITE OUT HDR FOR LAST, NEXT MONTH, THEN DAYS X ix = 3 X if (lmneven(lm)) ix = ix + 1 X call dtcat(ix, 1) X write(*,6) lmonth X ix = 61 X if (lmneven(nm)) ix = ix + 1 X call dtcat(ix, 1) X write(*,6) monthn X 6 format ($, 9(1a1, 1x)) X call dtcat(1, 2) X write(*,7) X 7 format($,'Su Mo Tu We Th Fr Sa', X 1 T60,'Su Mo Tu We Th Fr Sa') Xc call dtcat(35, 7) XC Center year above cur month Xc write(*,96) temp Xc 96 format ('$', 4(x, a1)) X Xc Now display last month, header for this month, and next month: X Xc Last month to upper-left corner of screen X X call dtcalcdow(ib,il,lm,ly) X call dtcdspmth(ib,il,0,0,-1,0) X If ((irm .eq. lm) .and. (iry .eq. ly)) then XC today in rev video X irdw = mod (ird + ib - 2, 7) XC Day of week (orig 0) X irwk = (ird + ib - 2)/7 XC Week in month (orig 0) X call dtcat ((irdw*3) + 2, irwk + 3) X write (*,684) esc,revattr, ird, esc,resetvattr X end if X Xc Next month to upper-right corner of screen X X call dtcalcdow(ib,il,nm,ny) X call dtcdspmth(ib,il,58,0,-1,0) X If ((irm .eq. nm) .and. (iry .eq. ny)) then XC today in rev video X irdw = mod (ird + ib - 2, 7) XC Day of week (orig 0) X irwk = (ird +ib - 2)/7 XC Week in month (orig 0) Xc added 1 to x coord in dtcat for amiga fixup here and just above. X call dtcat ((irdw*3) + 60, irwk + 3) X write (*,684) esc,revattr, ird, esc,resetvattr X end if X Xc display big banner header name of this month: X Xc call dtcat(ix,9) X call dtcat(1,9) X X call dtcmthnam(im,monthn) X X ix = 11 X if (lmneven(im)) ix = ix + 1 X ixx = ix - 9 X ixy = 14 - ix X ixx2=ixx+ixx X ixy2=ixy+ixy Xc double spaces for single-wide char screen to emulate dbl wide char screen X write(lxfixx,2220)ixx2 X2220 format(i2.2) X write(lxfixy,2220)ixy2 X write(*,lxfmt)temp,monthn,temp Xc write(*,225)temp Xc 8 format(3a, 4(a1, x), <ixx>x, 9(x,a1), <ixy>x, 4(x, a1), $) Xc write(*,8) ' ', esc,dhdw2, temp, monthn, temp X Xc Now print the week day headers for this month, and the days for this month: X X call dtcat(1,11) X write(*,10) X 10 format($, X 1 ' S u n M o n T u e s W e d s T h u r s', X 1 ' F r i S a t') Xc x x x x x x x x X XC Mark double-width lines Xc write (*,138) Xc 1 esc,'[13H', esc,dwide, Xc 2 esc,'[15H', esc,dwide, Xc 3 esc,'[17H', esc,dwide, Xc 4 esc,'[19H', esc,dwide, Xc 5 esc,'[21H', esc,dwide, Xc 6 esc,'[23H', esc,dwide X 138 format ($, 24a, $) Xc X call dtcalcdow(ib,il,im,iy) X call dtcdspmth(ib,il,8,8,9,1) XC For single-width Xc call dtcdspmth(ib,il,1,3,9,1) XC For double-width Xc X If ((irm .eq. im) .and. (iry .eq. iy)) then XC today in rev video Xc X irdw = mod (ird + ib - 2, 7) XC Day of week (orig 0) X irwk = (ird + ib - 2)/7 XC Week in month (orig 0) X call dtcat ((irdw*11)+9, (irwk*2)+13) X X if (id .eq. ird) then X write (*,684) esc,'[4;7m', ird, esc,resetvattr X else X write (*,684) esc,revattr, ird, esc,resetvattr X go to 685 XC And show looking-at date X end if X X 684 format($, 2a, i2, 2a, $) X X else X X 685 irdw = mod (id + ib - 2, 7) XC Day of week (orig 0) X irwk = (id + ib - 2)/7 XC Week in month (orig 0) X call dtcat ((irdw*11)+9, (irwk*2)+13) X X write (*,684) esc,'[4m', id, esc,resetvattr X X end if X X if (rdspfg .eq. 0) then X rchr='*' X out(1) = ' ' X else X rchr=' ' X out(1) = '*' X end if X X Do (i= 2, 31) XC set the out array to all blanks: X out(i) = out(1) X end do X Xc Now for files I/O to put *'s on days with appointments: X X irqhash(1) = ihymd(iy, im, 1) XC Want entries for X irqhash(2) = ihymd(iy, im, 31) XC current month X X eofflg = -1 X prveof = 0 X X do while (prveof .ge. 0) X X call dtcrdappt(eofflg, 0) X if (eofflg .ge. 0) out(ihd) = rchr X prveof = eofflg X X end do X Xc Have now accumulated all info about current month, Xc go back and flag appropriate days X X iy = 13 X ip = ib - 1 X X Do (i=1,il) X X ip = ip + 1 XC increment day number X If ( ip .gt. 7 ) then XC is it Sunday again? X ip = 1 XC reset day to Sunday. X iy = iy + 2 XC move down one line X End If X X if (out(i) .ne. 32) then XC Write only non-blank entries XC X ix = 11 * ip - 4 Xc ix = 6 * ip - 5 X call dtcat(ix,iy) XC position cursor X write(*,231) out(i) XC write * to screen X 231 format($,a1, $) X end if X end do XC # days in month X X 999 call dtcat(1,23) XC Position for next prompt X X end XC -h- fnscan.for Tue Jul 8 16:05:30 1986 Xc subroutine FNSCAN - scan file-name record (999999999x<filespec>=) Xc and strip space, mark 0 at end of name X X subroutine fnscan(work, maxlen, iwkln, ijr) X X INTEGER*1 work(maxlen) X X INTEGER*1 ll X X ij = 0 XC Initialize output index X do (ii=1, min0(iwkln, maxlen)) XC Start loop X ll = work(ii) XC Get input character X if (ll .gt. 32) then XC Strip all spaces & ctls X if (ll .eq. ichar('=')) go to 10 XC '=' marks end X ij = ij + 1 XC Character accepted X work(ij) = ll XC Copy it X end if XC (graphic character) X end do XC Loop X X 10 work(min0(ij+1,maxlen)) = 0 XC Set marker for OPEN X X ijr = ij XC Return length of string X X end XC -h- week.for Tue Jul 8 16:05:58 1986 Xc----------------------------------------------------------------------- XC Week-at-a-glance subroutine XC part of Mitch Wyle's DTC program XC Input: Xc line - 72 INTEGER*1 string; Format: W [mmddyy] XC Output: Xc display screen (see below) XC----------------------------------------------------------------------- XC Modified 850117 to fix leap-year problems - CG Xc Modified 850314 to use real corners, lines and T's for box - CG Xc Modified 850318 to display current date in reverse video - CG Xc Modified 850806 to use new subroutines (including DTCRDAPPT) Xc and get rid of previously commented-out code Xc X SUBROUTINE week XC (line) XC Declarations: Xc X include comdtc.INC X include apptdtc.INC X include escdtc.INC Xc X INTEGER*1 ln1, ll XC equiv to input line X INTEGER*1 temp(2) XC temporary string converting array X logical apts(7,19), aptsln(133), tflg X Integer*4 prveof, eofflg X Integer*4 HASH X Integer*4 id XC Julian Day X Integer*4 im XC Julian Month X Integer*4 iy, iyd XC Julian Year X Xc lengths of months ... leap years adjusted in code Xc December Jan ... Dec Jan X Integer*4 ml(14) X include stmtfuncsp.for X equivalence (line, ln1), (apts, aptsln) X include comdtcd.inc X include escdtcd.inc X Data ml X 1 /31, 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31/ X X include stmtfunc.for X Xc Initialize: X X iss = z'7FFFFFFF' XC Impossible saved Sunday day... X iwf=0 XC Adjustment factor X X if ((ln1 .and. ucmask) .eq. Ichar('W')) X 1 call shrink(1, ifnb, lnb) X X call dtcidate(imx,idx,iyx) XC initialize to today's date X X call dtcdatcvt(3) XC Get date string X X im=idmo XC Copy values X id=iddy X iy=ibigyr X X if (islpyr(iy)) then X ml(3)=29 XC Feb is in ML(3), not ML(2) XC X else X ml(3)=28 XC C Garman, 17-Jan-1985 X end if X XC Where we look for free space of n units or more length, XC then just display reverse and zot out all shorter periods X X if (ctlfg .eq. 1) rdspfg=1 X tflg = (rdspfg .ne. 0) XC initialize flag X do (ij = 1, 7*19) X aptsln(ij) = tflg X end do X X if (ctlfg .ne. 0) then XC Locate N X X intsz = 0 X i = 1 X do while(numeric(line(i))) X intsz = (intsz * 10) + icvtbn1(line(i)) X i = i + 1 X if (i .gt. icmln) go to 1191 X end do X Xc clamp interval size to permissible range... X X 1191 intsz = min0(max0(intsz, 1), 18) X X end if XC Paint the screen: Xc X Xc following sequence moves to upper left corner on VT100 compatible terminals Xc and clears screen X X write(*,6) esc,homescrn, esc,clrscrn X 6 format(1x,4a,$) X call dtcat(1,1) Xc Now write box, in graphics mode, to enclose days of week X X write (*, 70) '+', '+' XC Upper corners & top line Xc X irow=2 X Do (i = 1, 6) XC 6 more days' worth X Call DtcAt(1,irow) X irow=irow+1 X write (*, 71) X Call DtcAt(1,irow) X irow=irow+1 X write (*, 71) X Call DtcAt(1,irow) X irow=irow+1 X write (*, 72) X end do Xc X Call DtcAt(1,irow) X irow=irow+1 X write (*, 71) X Call DtcAt(1,irow) X irow=irow+1 X write (*, 71) XC two more sides X Call DtcAt(1,irow) X irow=irow+1 X write (*, 73) '+', '+' XC Lower corners & bottom line Xc X 70 format (x, 1a1, 74('-'), 1a1) XC Upper/lower corners XC sides X 71 format (x, '|', 74(' '), '|') X 72 format (x, '+', 74('-'), '+') XC interior lines X 73 format (x, 1a1, 74('-'), 1a1) XC Upper/lower corne1rs X X call dtcat(2,2) X write(*,10) ' Sunday' X 10 format($,a) X call dtcat(2,5) X write(*,10) ' Monday' X call dtcat(2,8) X write(*,10) ' Tuesday' X call dtcat(2,11) X write(*,10) 'Wednesday' X call dtcat(2,14) X write(*,10) ' Thursday' X call dtcat(2,17) X write(*,10) ' Friday' X call dtcat(2,20) X write(*,10) ' Saturday' X XC Now figure out which Sunday is closest to the day specified by id: Xc X X call dtcalcdow(ib,il,im,iy) XC Remember: ib = 1st day of month X Xc il = length of month Xc ib = day number of 1st day of month, 1=sunday. X X if ( ib .eq. 1 ) then X is = 1 XC IS is the Sunday we want. It is X else XC either the 1st day of the month X is = 9 - ib XC or 9 - 1st day of month. X end if X XC Now...Sunday may be in preceding month X 11 continue XC If the day is not in the 1st week Xc try to fix up case of wrong sunday.. Xc ML array is preceding month's length X iwf=0 X if (id .lt. is) then X is=is-7+ml(im) X im=im-1 X if (im .le. 0) then Xc adjust year wrapback X im=12 X iy=iy-1 X end if X il=ml(im+1) X iwf=-il X go to 301 X end if X if ( ( id - is ) .ge. 7 ) then XC of the month, then keep adding X is = is + 7 XC 7 until we get to the week we X go to 11 XC want. X end if X 301 continue Xc since we can wrap months down as well as up construct date limits here... Xc *** if (iy .gt. 1900) iy=iy-1900 Xc just generate a hashcode that is strictly increasing as a function of Xc date. only purpose is to be monotonic increasing, so continuity is Xc not important. we use other methods to handle exact offsets. note that Xc where wrap arounds occur, iss is allowed to be a little larger than Xc real month length or a small negative where used below...not here. X X irqhash(1) = ihymd(iy, im, is) X iss = is XC don't lose track of Sunday's date. X issss = is XC It will be important later... XC Now figure out where to write the dates of the days of the week, Xc and write em out where they belong: Xc X iyd = mod(iy, 100) XC Display two digits X X Do (i=1,7) X jy = 3 * i X call dtcat(2,jy) X if ((im .eq. imx) .and. (iy .eq. iyx)) then X if (is .eq. idx) then X if (id .eq. idx) then XC reverse + underline X write(*,130,err=99) X 1 esc,'[4;7m', im,is,iyd, esc,resetvattr X else XC reverse only X write(*,130,err=99) X 1 esc,revattr, im,is,iyd, esc,resetvattr X end if X else X go to 684 X end if X else X 684 if (is .eq. id) then XC underline only X write(*,130,err=99) X 1 esc,'[4m', im,is,iyd, esc,resetvattr X else XC N/O/T/A, nothing fancy X write(*,13,err=99) im,is,iyd X end if X end if X X 99 is = is + 1 X If ( is .gt. il ) then XC Did the month change X is = 1 XC during this week? X im = im + 1 X If ( im .gt. 12 ) then XC Did the year change X im = 1 XC during this week? X iy = iy + 1 X iyd = mod(iy, 100) X End If X End If X X irqhash(2) = ihymd(iy, im, is) XC save last day value in hash X X end do X X 13 format($, i3, '/', i2.2,'/',i2.2) X 130 format($, a1, a, i3, '/', i2.2,'/',i2.2, a1, a) X XC Now for Files I/O: Xc X Xc Set up a boolean array of appointment times and days of Xc the week. Notice that if this program were written in Xc assembler, we would use only 18 INTEGER*1s and store this Xc information by bits instead of INTEGER*1s. Oh well. There Xc goes 100 INTEGER*1s of storage space... Xc When life confronts you with its troubles and woes, Xc Have no fear, just fire photon torpedos XC X XC Read the appointments; If the appointment is for one of Xc the days in this week, mark that spot in the appointments Xc array true. Otherwise that coordinate is false. The array Xc looks like this: XC Su Mo Tu We Th Fr Sa XC 8:00 T F F F F F F XC Appointment on Su at 8:00 Xc 8:30 F T T T F F F XC Appointments on Mo, Tu, We at 8:30 Xc 9:00 F F F F F F F XC No appointments at 9:00 this week Xc 9:30 XC . . . . . . . . Xc . . . . . . . . etcetera Xc . . . . . . . . Xc XC sic itur ad astra XC Etcetra. Caveat emptor and three other latin words. XC X prveof = 0 X eofflg = -1 X X do while (prveof .ge. 0) X X call dtcrdappt(eofflg, 0) XC Look at appointments file X X if (eofflg .ge. 0) X 1 then X XC NOW we are testing the date range validly. However, we must adjust XC the ISS range to be in the range from - (small #) to + XC (or some such) to take into account the fact that it MUST be XC continuous in order to be transformed into a cursor address. XC FORTUNATELY we saved the appropriate length of month adjustment XC above so can add it back in here. IWF=0 most times. X X iss=issss+iwf X jx = ihd - iss + 1 XC need a little more logic to handle crossing months here Xc where jx >7 we have to adjust by length of month once more... X if (jx .gt. 7) jx=jx+iwf Xc also have to handle cases where we crossed months, by adding in Xc length of previous month. X if (jx .le. 0) jx=jx+ml(im) X jy = min0(max0(((iht+2)/5)-15, 1), 19) X X if ((jx .ge. 1) .and. (jx .le. 7) .and. X 1 (jy .ge. 1) .and. (jy .le. 19)) X 2 then X X apts(jx,jy) = .not. tflg XC Derived a long time ago XC X X end if X X end if X X prveof = eofflg X X end do XC while XC Now display the information we have extracted: Xc X if (ctlfg .ne. 0) then Xc here go through and look for "intsz" sized intervals and Xc set apts(i,j) to .false. if the interval is too small... X k=19-intsz X Do (i=1,7) X Do (j=1,k) X ivl=1 X Do (l=1,intsz) X if (.not. apts(i,j+l-1)) ivl=0 X end do X if (ivl .ne. 1) apts(i,j)= .false. X end do Xc since we are showing valid start times, set all times at the end of Xc the day false since they can't possibly be valid times for any Xc meetings. X kk=k+1 X if (kk .le. 18) then X do (j=kk,18) X apts(i,j)= .false. X end do X end if X end do X End If X X Do (i=1,7) XC Go through the entire X Do (j=1,19) XC array and display X If ( apts(i,j) ) then XC appts if they exist: X jx = 6 * j + 10 XC jx is x coord of cursor X jy = 3 * i - 1 XC jy is y coord of cursor X X If ( jx .gt. 74) then XC For afternoon and evening X jy = jy + 1 XC appointments, put the X jx = jx - 63 XC appointments on the second X End If XC line of the day X X jj = j XC Now decode the time again X call dtcat(jx,jy) XC to display. jj is time X if (((j/2)*2) .ne. j) then XC of appointment X jj = jj + 7 - (jj/2) XC If the time is odd then X write(*,16) jj XC it falls on the hour. X 16 format($,i2,':00') X else X jj = jj + 7 - (jj/2) XC If the time is even then X write(*,17) jj XC it falls on the half hour X 17 format($,i2,':30') X end if X End If X end do X end do X X 999 call dtcat(1,22) XC move cursor to the bottom X end XC of the screen and return XC -h- year.for Tue Jul 8 16:06:21 1986 Xc----------------------------------------------------------------------- XC Year-at-a-glance subroutine XC part of Mitch Wyle's DTC program XC Input: Xc line - 72 INTEGER*1 string; Format: Y [yy] XC Output: Xc display screen (see below) XC----------------------------------------------------------------------- Xc X X SUBROUTINE year XC (line) X Xc Declarations: X X include comdtc.INC X include escdtc.INC X X INTEGER*1 temp(4), ln1 X Character*4 tempc X Equivalence(tempc,temp(1)) X Character*2 tempc2 X Equivalence(tempc2,temp(1)) XC temporary string converting array X X Integer*4 id, idr XC Julian Day X Integer*4 im, imr XC Julian Month X Integer*4 iye, iyr XC Julian Year X Integer*4 iyo XC y offset for where to put month data X Integer*4 ix XC x coord of cursor X Integer*4 iy XC y coord of cursor X Integer*4 img XC month loop index goes from 1 to 12 X Integer*4 jg XC index offset defined by img X Integer*4 ii XC implied do loop index variable X INTEGER*1 monthn(9) XC string month name X real badf77 X real badftn XC Maybe error in array subscripts Xc string containing names of days of week X character*21 wknam XC Hoolay kan X INTEGER*1 ihold XC hold the screen X Xc Entries true if length of name is even X logical*1 lmneven(12) X X equivalence (line, ln1) X include comdtcd.inc X include escdtcd.inc X Data wknam X 1 / 'Su Mo Tu We Th Fr Sa|'/ X Data lmneven/ X 1 .false., .true., .false., .false., .false., .true., X 2 .true., .true., .false., .false., .true., .true./ X X X if ((ln1 .and. ucmask) .eq. ichar('Y')) X 1 call shrink(1, ifnb, lnb) X X call dtcdatcvt(1) XC Parse out a year value X X im=idmo X id=iddy X iye=ibigyr Xc X call dtcidate(imr,idr,iyr) XC initialize to today's date X XC to display in reverse video X Xc set screen to 132 col, double width for X write(*,300) esc,'[0;0H',esc,'[1J' XC Erase screen first in this mode... X write(*,300) esc,'[?3h', X 1 esc,'[2H', esc,'#6', X 2 esc,'[14H', esc,'#6' XC Month headers X Write(tempc,20,err=97)iye Xc encode (4, 20, temp, err=97) iye X 20 format(i4) X X 97 ix = 29 X iy = 11 X call dtcat(ix,iy) XC Display year in X write(*,305) esc,dhdw1, temp XC double height/double width Xc *******&&&& ?????? XC in the middle of the screen X iy = 12 X call dtcat(ix,iy) X write(*,305) esc,dhdw2, temp XC second line X X 99 Do 4 img = 1,12 XC for each month: X call dtcmthnam(img,monthn) XC Find out name, and display it X jg = img - 1 XC x coord of cursor for month X if (jg .gt. 5) jg = jg - 6 XC name in outstring X ix = ( jg * 22 ) + 1 XC X if (img .gt. 6) then XC First six months on top X iy = 14 XC last six months on bottom X else XC half of screen X iy = 2 X end if Xc ixx = (ix/2) + 2 Xc *** if (lmneven(img)) ixx = ixx + 1 X call dtcat(ix,iy) Xc call dtcat(ixx,iy) XC Position cursor and: X write(*,3) monthn X 3 format($,21a1) XC Write out the name. X 300 format($,40a) X 305 format($, 2a, 4(x, a)) X 399 format($,a21) XC Write out the name. X If (img .gt. 6) then XC Write out day of week X iy = 15 XC Header names also, one X else XC line below month names X iy = 3 X end if X call dtcat(ix,iy) X write(*,399) wknam X X If (img .gt. 6) then XC Write out numbers for X iy = 15 XC Days in each month: X iyo = 12 X else X iy = 4 X iyo = 0 X end if X call dtcalcdow(ib,il,img,iye) XC Now position the month X ix = ix - 1 XC Off by 1. CORRECT IT X ixspa = 0 X ixo = 0 X iyspa = 0 X call dtcdspmth(ib,il,ix,ixspa,iyo,iyspa) X Xc If displaying current year, mark today's date in reverse video X X if ((iye .eq. iyr) .and. (img .eq. imr)) then X idw = mod(ib + idr -2, 7) XC Day of week and X iwm = (idr + ib - 2)/7 XC week of month (orig 0) X if (img .gt. 6) iwm = iwm + 1 XC Down one more line for Jul-Dec X call dtcat((idw * 3) + ix + 1, iy + iwm) X write (*, 301) esc,'[5;7m', idr, esc,resetvattr X 301 format ($, 2a, i2, 2a, $) X end if X 4 Continue X X call dtcat (1,23) XC Reposition cursor X Xc return next line read in and allow main pgm to decode... X read(*,80,END=914)line X 80 format(84a1) X 914 Continue X write(*,300) esc,'[?3l' X Return X end XC -h- strip.for Tue Jul 8 16:06:45 1986 Xc----------------------------------------------------------------------- XC Strip Daily Appointment subroutine (DTC Purge command) XC part of GLENN EVERHART'S MODS TO DTC program XC Input: command line - 72 INTEGER*1s, format: XC P [mmddyy] Xc or Xc U [mmddyy] [hh:mm[>hh:mm]] Xc or Xc X [mmddyy] [hh:mm[>hh:mm]] [mmddyy] [hh:mm[>hh:mm]] XC Output: Xc Reads dtc.dat, and builds new dtc.dat, in the process Xc strips old appointments (before date) from file (P), Xc deletes appointments at specified time and date (U), Xc or re-schedules (eXchanges) appointments from d1*t1 to d2*t2 Xc for Amiga, since we don't have version numbers, build DTC.TMP and Xc copy onto DTC.DAT (or whatever) later... XC----------------------------------------------------------------------- Xc X X SUBROUTINE strip XC (line) X XC Declarations: Xc X include comdtc.INC X include apptdtc.INC Xc XC Function constants: Purge XC .. Unschedule X parameter (idspp = 1) X Parameter (idspu = 2) X Parameter (idspx = 3) XC .. eXchange XC INTEGER*1 line(1) XC input line XC temporary string converting array X INTEGER*1 temp(2), ll, X 1 ln1, ap1 XC For RDAPPT 'do while' loop X Integer*4 eofflg, prveof, X 1 firstflg X Integer*4 id, idx XC Julian Day X Integer*4 im, imx XC Julian Month X Integer*4 iye, iyx XC Julian Year X Integer*4 it1, it2, itx1, itx2 XC time values 80 (8 AM) => 173 (5:30 PM) Xc X logical first XC For X decode X Character*1 ln1c X equivalence (line, ln1) Xc equivalence (appoin, ap1) X Equivalence (ln1,ln1c) X include stmtfuncsp.for X include comdtcd.inc Xc X include stmtfunc.for XC Get standard statement functions X Xc Parse input line: Xc Was there a P on the front? If so, trim it off: Xc X X iopn2=0 Xc flag we opened DTC.TMP, 1 if true... X isavinc = incmod XC Save for increment in DATCVT X X first = .true. XC Set it regardless of path X X If ( ln1c .eq. 'P' ) then X X idisp = idspp XC Function to perform X X else X X if (ln1c .eq. 'U') then X idisp = idspu X else if (ln1c .eq. 'X') then X idisp = idspx X else X go to 999 XC Error, can't decode it X end if X X it1 = 80 XC Set comparison values X it2 = 180 X itx1 = it1 X itx2 = it2 X X End If X X call shrink (1, ifnb, lnb) X X if (ifnb .eq. 0) then X if (idisp .eq. idspp) then X call dtcidate(im,id,iye) XC set to today's date X else X go to 999 XC Not enough info for U or X X end if X else XC If the date was specified in command line then Xc set id, im and iye to the right values: Xc X 10 call dtcdatcvt(3) XC (line) X X if (first) then XC Note we decode into X im = idmo XC second set of values, X id = iddy XC then copy into first set X iye = ibigyr XC first (or only) time around END_OF_FILE if test 37658 -ne `wc -c <'Dtc2.For.ab'`; then echo shar: \"'Dtc2.For.ab'\" unpacked with wrong size! fi # end of 'Dtc2.For.ab' fi echo shar: End of archive 3 $of 6$. cp /dev/null ark3isdone MISSING="" for I in 1 2 3 4 5 6 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked all 6 archives. rm -f ark[1-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0 -- Mail submissions (sources or binaries) to <amiga@cs.odu.edu>. Mail comments to the moderator at <amiga-request@cs.odu.edu>. Post requests for sources, and general discussion to comp.sys.amiga.